perm filename MAKNUM.F4[P11,LCS] blob sn#573358 filedate 1981-03-15 generic text, type T, neo UTF8
00100		 SUBROUTINE MAKNUM(RNUM)
00200	       COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
00300		1 /STF/RSTFAC(8),RSTJ2
00400		1 /NFONT/NFONT
00500	C*** PUT THIS IN AFTER ALPHA IS TRANSLATED
00600	      EQUIVALENCE (J3,JQ(1)),(R4,RJQ(2)),(R8,RJQ(6)),(R7,RJQ(5))
00700	     1,(R6,RJQ(4)),(R5,RJQ(3)),(R7,RJQ(5)),(JQ(15),B),(JQ(16),C)
00800	     1 ,(J8,JQ(6)),(J10,JQ(8)),(R3,RJQ(1)),(J5,JQ(3)),(RJY,JQ(19))
00900	     1 ,(J7,JQ(5)),(J6,JQ(4)),(R9,RJQ(7))
01000	      DATA RS/10.0/,RBX/1.0/
01100	      RB8=R8
01200	      J3X=J3
01300	C P7=0=BDR40; =1=BDI40; =2=PRIM.
01400		IF(R6.GE.100.)R6=R6-100.
01500		IF(R6.EQ.0)R6=1.
01600		R5=R6
01700	C IF R6 > 100 IT'S FOR THE PAGE PROG.  SUBTRACT 100 TO GET TRUE SIZE
01800	C  IF IT'S 0 MAKE INTO 1.0   UPPER CASE - BDR40
01900		IF(R7.GT.2.)R7=0
02000	      R6=48000000.0+(R7+50.)*10000.
02100	      R7=99999999.0
02200	C  BLANKS
02300		ONE=0
02400	      IF(RNUM.NE.9999.)GO TO 2
02500	C  NEXT FOR 'C'OMMON TIME
02600	      RNUM=12.
02700	C  MAKES A 'C'
02800	      R4=R4-2.2
02900	C  .2 FOR BAD POS. OF LETTERS
03000		GO TO 4
03100	2     RNUM=IFIX(RNUM)
03200	C  SO MISTAKES (I.E. 2.2) WON'T BREAK THE PROG.
03300	      IF(RNUM.EQ.1.)ONE=3.
03400	      IF(RNUM.GT.9.)GO TO 3
03500	C  JUMP FOR 2 OR 3 DIGIT NUMBER
03600	4     R6=R6+RNUM*100.+47.
03700	C  PUTS BLANK ON END (.47)
03800		GO TO 1
03900	3     RJY=10.
04000	      IF(RNUM.GE.100.)RJY=100.
04100	      B=IFIX(RNUM/RJY)
04200	      C=AMOD(RNUM,RJY)
04300	      IF(RNUM.LT.100)GO TO 7
04400	      D=IFIX(C/10.)
04500	      C=AMOD(C,10.)
04600	      IF(C.EQ.1.)ONE=ONE+3.
04700	      R7=C*1000000.+999999.0
04800		C=D
04900	7     R6=R6+B*100.+C
05000	      IF(B.EQ.1.)ONE=ONE+3.
05100	      IF(C.EQ.1.)ONE=ONE+3.
05200	      B=R5
05300	      IF(RNUM.GE.100.)B=B*2
05400	      J3=J3-RS*RSTJ2*B
05500	C  FOR 2 DIGIT NUMBER   ADJUSTS FOR 11, ETC.
05600	1     J3=J3+ONE*R5*RSTJ2
05700	C CENTERS THE NUMBER '1'
05800		MFONT=NFONT
05900	      CALL ALPHA
06000		NFONT=MFONT
06100	C RESTORE FONT TO WHATEVER IT WAS BEFORE
06200	      J3=J3X
06300	      IF(RB8.EQ.0)RETURN
06400	C NEXT FOR CIRCLES AND BOXES AROUND NUMBERS.
06500		R3=J3-R5
06600	      IF(J10.EQ.0)J10=1
06700	C USE J10 FOR EVEN THICKER BOX AND CIRC.
06800	      IF(RNUM.GT.9)R3=R3+R5*RBX
06900	C  TO SET CENTER
07000	      IF(RB8.EQ.2.)GO TO 5
07100	      R4=R4+R5+.1+.05/R5
07200	C  END OF ABOVE IS FOR SMALL CIRCLES.
07300	      B=4.5
07400	      IF(RNUM.GE.100.)B=5.5
07500	      R5=R5*B
07600		J6=0
07700		J7=0
07800		J8=J10
07900		CALL CENTX
08000		CALL CIRCLE
08100		RETURN
08200	5	B=6.
08300		R9=0
08400	      IF(RNUM.LT.100.)GO TO 8
08500	      B=9.
08600	      R9=R5*6.
08700	C  MAKES RECTANGLE IF >=100
08800	8     R4=R4+R5*.7+.1
08900	      R8=R5*B
09000	      J5=50
09100		 R3=R3+1.0
09200	C   SHIFT BOX SLIGHTLY TO RIGHT
09300		CALL ITMSUB
09400		END